Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbpcopy/jmfile.bas

BASIC Source File | 1998-10-06 | 6KB | 218 lines

Attribute VB_Name = "JMFileSubs"
Option Explicit
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Function JMTestDirectory(argDirectory As String) As Integer
    Dim wrkDirectory As String
    Dim wrkString As String
    JMTestDirectory = False
    On Error GoTo JMTestDirectoryError
    wrkDirectory = Trim$(argDirectory)
    Select Case Len(wrkDirectory)
    Case 0, 1
    Case 2
        If (Mid$(wrkDirectory, 2, 1) = ":") Then JMTestDirectory = True
    Case 3
        If (Mid$(wrkDirectory, 2, 1) = ":" And Mid$(wrkDirectory, 3, 1) = "\") Then
            JMTestDirectory = True
        End If
    Case Else
        wrkString = Dir$(wrkDirectory, 16)
        If (wrkString <> "") Then JMTestDirectory = True
    End Select
    Exit Function
JMTestDirectoryError:
    Err.Clear
    Exit Function
End Function

Function JMAddMissingBackslash(argInput As String) As String
    On Error Resume Next
    JMAddMissingBackslash = argInput
    If (argInput = "") Then Exit Function
    If (Right$(argInput, 1) <> "\") Then
        JMAddMissingBackslash = argInput & "\"
    End If
End Function

Public Function JMShortFileName(argFile As String) As String
    Dim wrkFile As String
    Dim wrkFlag As Long
    Dim wrkLength As Integer
    On Error Resume Next
    JMShortFileName = argFile
    If (argFile = "") Then Exit Function
    wrkLength = 400
    wrkFile = Space(wrkLength)
    wrkFlag = GetShortPathName(argFile, wrkFile, wrkLength)
    wrkLength = lstrlen(wrkFile)
    JMShortFileName = Left$(wrkFile, wrkLength)
End Function

Public Function JMExtractFileName(argPath As String) As String
    Dim wrkPos As Integer
    On Error Resume Next
    JMExtractFileName = ""
    If (argPath <> "") Then
        wrkPos = JMStringLastBackslash(argPath)
        If (wrkPos > 0) Then
            JMExtractFileName = Mid(argPath, wrkPos + 1)
        Else
            JMExtractFileName = argPath
        End If
    End If
End Function

Function JMStringLastBackslash(argPath As String) As Integer
    Dim wrkPos As Integer
    Dim wrkPos2 As Integer
    On Error Resume Next
    JMStringLastBackslash = 0
    wrkPos = 0
    wrkPos2 = 0
    If (argPath = "") Then Exit Function
    Do
        wrkPos = InStr(wrkPos2 + 1, argPath, "\")
        If (wrkPos = 0) Then
            JMStringLastBackslash = wrkPos2
            Exit Function
        End If
        wrkPos2 = wrkPos
    Loop
End Function

Public Function JMExtractFileExtension(argPath As String) As String
    Dim wrkPos As Integer
    On Error Resume Next
    JMExtractFileExtension = ""
    If (argPath <> "") Then
        wrkPos = JMStringLastDot(argPath)
        If (wrkPos > 0) Then
            JMExtractFileExtension = Mid(argPath, wrkPos + 1)
        End If
    End If
End Function

Function JMStringLastDot(wrkInput As String)
    Dim wrkPos As Integer
    Dim wrkPos2 As Integer
    On Error Resume Next
    JMStringLastDot = 0
    wrkPos = 0
    wrkPos2 = 0
    If (wrkInput = "") Then Exit Function
    Do
        wrkPos = InStr(wrkPos2 + 1, wrkInput, ".")
        If (wrkPos = 0) Then
            JMStringLastDot = wrkPos2
            Exit Function
        End If
        wrkPos2 = wrkPos
    Loop
End Function

Function JMFileExists(argFile As String)
    Dim wrkFree As Integer
    On Error Resume Next
    JMFileExists = False
    On Error GoTo JMFileExistsError
    If (argFile = "") Then Exit Function
    wrkFree = FreeFile
    Open argFile For Input As wrkFree
    JMCloseFile wrkFree
    JMFileExists = True
    On Error Resume Next
    Exit Function
JMFileExistsError:
    Err.Clear
    JMCloseFile wrkFree
    Exit Function
End Function

Sub JMCloseFile(argFile As Integer)
    On Error GoTo JMCloseFileError
    Close argFile
JMCloseFileError:
    Exit Sub
End Sub

Function JMOpenInputFile(argFile As String) As Integer
    JMOpenInputFile = False
    On Error GoTo JMOpenInputFileError
    Open argFile For Input Access Read As #1
    JMOpenInputFile = True
JMOpenInputFileError:
    Exit Function
End Function

Function JMOpenOutputFile(argFile As String) As Integer
    JMOpenOutputFile = False
    On Error GoTo JMOpenOutputFileError
    Open argFile For Output Access Write As #2
    JMOpenOutputFile = True
JMOpenOutputFileError:
    Exit Function
End Function

Public Function JMFileCopy(argSource As String, argDestination As String) As Integer
    JMFileCopy = False
    On Error GoTo JMFileCopyError:
    If (JMFileExists(argSource) = False) Then Exit Function
    If (JMFileExists(argDestination) = True) Then Exit Function
    FileCopy argSource, argDestination
    JMFileCopy = True
JMFileCopyError:
    Exit Function
End Function

Function JMShortFilePathDisplay(argPath As String) As String
    Dim kk As Integer
    Dim wrkStringLength As Integer
    Dim wrkPos1 As Integer
    Dim wrkPos2 As Integer
    Dim wrkSlashes As Integer
    On Error Resume Next
    wrkStringLength = Len(argPath)
    wrkSlashes = 0
    wrkPos1 = 0
    wrkPos2 = 0
    For kk = 1 To wrkStringLength
        Select Case Mid$(argPath, kk, 1)
        Case "\"
            wrkSlashes = wrkSlashes + 1
            If (wrkSlashes = 2) Then wrkPos1 = kk
            wrkPos2 = kk
        End Select
    Next kk
    If (wrkSlashes < 4) Then
        JMShortFilePathDisplay = argPath
        Exit Function
    End If
    JMShortFilePathDisplay = Left$(argPath, wrkPos1) & "..." & Mid$(argPath, wrkPos2)
End Function

Public Function JMExtractFileNameOnly(argFile As String) As String
    Dim wrkPos As Integer
    Dim wrkString As String
    On Error Resume Next
    wrkString = JMExtractFileName(argFile)
    If (wrkString <> "") Then
        wrkPos = JMStringLastDot(wrkString)
        If (wrkPos > 0) Then
            wrkString = Left$(wrkString, wrkPos - 1)
        Else
            wrkString = wrkString
        End If
    End If
    JMExtractFileNameOnly = wrkString
End Function

Public Sub JMOutputPrint(argString As String)
    On Error GoTo JMOutputPrintError:
    Print #2, argString;
JMOutputPrintError:
    Exit Sub
End Sub